home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0921.ZIP / INT24.ARC / INT24.PAS < prev    next >
Pascal/Delphi Source File  |  1988-01-02  |  9KB  |  233 lines
  1. {$I-,R-,S-}
  2.  
  3. unit Int24;
  4.  
  5. { A unit for trapping DOS critical errors (INT 24) for retries
  6.  
  7.   Version 1.01 - 01/02/1987 - First general release
  8.  
  9.   Scott Bussinger
  10.   Professional Practice Systems
  11.   110 South 131st Street
  12.   Tacoma, WA  98444
  13.   (206)531-8944
  14.   Compuserve 72247,2671 }
  15.  
  16.  
  17. interface
  18.  
  19. uses Dos,
  20.  
  21. {$IFDEF TPROF}                                   { You must DEFINE TPROF to use the Turbo Professional routines }
  22.      TPCrt;
  23. {$ELSE}
  24.      Crt,FastWr,Cursors;
  25. {$ENDIF}
  26.  
  27. var CriticalProc: pointer;                       { Address of special critical error handler }
  28.  
  29. implementation
  30.  
  31. const Attr = $70;
  32.  
  33. var ExitSave: pointer;
  34.     OldInt24: pointer;
  35.     CurrentCriticalProc: pointer;
  36.  
  37. procedure CallUserHandler(var Retry: boolean;ErrorCode: word;var DeviceName: string);
  38.   inline($FF/$1E/>CurrentCriticalProc);          { CALL DWORD [>CurrentCriticalProc] }
  39.  
  40. procedure JmpOldISR(OldISR: pointer);
  41.   inline($5B/                   {  pop bx             ;BX = Ofs(OldIsr)}
  42.          $58/                   {  pop ax             ;AX = Seg(OldIsr)}
  43.          $87/$5E/$0E/           {  xchg bx,[bp+14]    ;Switch old BX and Ofs(OldIsr)}
  44.          $87/$46/$10/           {  xchg ax,[bp+16]    ;Switch old AX and Seg(OldIsr)}
  45.          $89/$EC/               {  mov sp,bp          ;Restore SP}
  46.          $5D/                   {  pop bp             ;Restore BP}
  47.          $07/                   {  pop es             ;Restore ES}
  48.          $1F/                   {  pop ds             ;Restore DS}
  49.          $5F/                   {  pop di             ;Restore DI}
  50.          $5E/                   {  pop si             ;Restore SI}
  51.          $5A/                   {  pop dx             ;Restore DX}
  52.          $59/                   {  pop cx             ;Restore CX}
  53.          $CB);                  {  retf               ;Chain to OldIsr, leaving CS and IP params on the stack}
  54.  
  55. {$F+}
  56. procedure Int24Handler(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP: integer); interrupt;
  57.   { Interrupt handler for the critical error interrupt }
  58.   type DeviceHeader = record
  59.          Next: pointer;
  60.          Attributes: word;
  61.          StrategyAddr: word;
  62.          InterruptAddr: word;
  63.          Name: array[1..8] of char
  64.          end;
  65.   var DeviceName: string[8];
  66.       Retry: boolean;
  67.       SaveCriticalProc: pointer;
  68.   begin
  69.   if (AX and $8000) = 0
  70.    then
  71.     DeviceName := chr(lo(AX)+ord('A')) + ':'     { Pass the drive name to user error handler }
  72.    else
  73.     with DeviceHeader(ptr(BP,SI)^) do
  74.       if (Attributes and $8000) = 0
  75.        then
  76.         DeviceName := ''                         { Bad memory image of FAT - no device name available }
  77.        else
  78.         DeviceName := copy(Name,1,pred(pos(' ',Name+' '))); { Get name of character device }
  79.  
  80.   Retry := false;
  81.   SaveCriticalProc := CriticalProc;
  82.   while CriticalProc <> nil do                   { Allow for a chain of user critical error handlers }
  83.     begin
  84.     CurrentCriticalProc := CriticalProc;
  85.     CriticalProc := nil;
  86.     CallUserHandler(Retry,lo(DI),DeviceName)
  87.     end;
  88.   CriticalProc := SaveCriticalProc;
  89.   if Retry
  90.    then
  91.     AX := 1
  92.    else
  93.     JmpOldISR(OldInt24)
  94.   end;
  95.  
  96. procedure DefaultCriticalHandler(var Retry: boolean;ErrorCode: word;var DeviceName: string);
  97.   { Default critical error handler for retrying on errors }
  98.   const ErrorDesc: array[0..12] of string[18] = ('', { List of generic descriptions of critical errors }
  99.                                                  'Unknown unit',
  100.                                                  '',
  101.                                                  'Unknown command',
  102.                                                  'Data error (CRC)',
  103.                                                  'Bad request length',
  104.                                                  'Seek error',
  105.                                                  'Unknown media type',
  106.                                                  'Sector not found',
  107.                                                  '',
  108.                                                  'Write fault',
  109.                                                  'Read fault',
  110.                                                  'General failure');
  111.         ScreenSize = 2000;
  112.   var CurrentAttr: byte;
  113.       CurrentLine: integer;
  114.       I: integer;
  115.       Key: char;
  116.       SaveCheckBreak: boolean;
  117. {$IFDEF TPROF}
  118.       SaveCursorLoc: word;
  119.       SaveCursorSize: word;
  120. {$ELSE}
  121.       SaveCursorSize: CursorSize;
  122.       SaveX: byte;
  123.       SaveY: byte;
  124. {$ENDIF}
  125.       SaveScreen: array[1..ScreenSize] of word;  { A place to save a copy of the screen temporarily }
  126.       SaveTextAttr: byte;
  127.  
  128.   procedure OutLine(Line: string);
  129.     { Output a line to the screen }
  130.     begin
  131.     if odd(length(Line)) then
  132.       Line := ' ' + Line;
  133.     while length(Line) < 44 do
  134.       Line := ' ' + Line + ' ';
  135.     FastWrite('║'+Line+'║',CurrentLine,18,Attr);
  136.     inc(CurrentLine)
  137.     end;
  138.  
  139.   begin
  140.   if not Retry then                              { See if another handler has already decided to retry the error }
  141.     begin                                        { Save screen and put up a warning message }
  142. {$IFDEF TPROF}
  143.     GetCursorState(SaveCursorLoc,SaveCursorSize); { Save current display }
  144.     MoveScreen(mem[VideoSegment:0],SaveScreen,ScreenSize);
  145. {$ELSE}
  146.     GetCursor(SaveCursorSize);
  147.     GetCursorLoc(SaveX,SaveY);
  148.     MoveFromScreen(mem[BaseOfScreen:0],SaveScreen,ScreenSize);
  149. {$ENDIF}
  150.     SaveTextAttr := TextAttr;
  151.     SaveCheckBreak := CheckBreak;
  152.     CheckBreak := false;
  153.     TextBackground(Black);
  154.     ClrScr;                                    { Display the error message }
  155.     CurrentLine := 10;
  156.     FastWrite('╔════════════════════════════════════════════╗',9,18,Attr);
  157.     OutLine('');
  158.     case ErrorCode of                            { Check for obvious problems }
  159.       0: begin
  160.          OutLine('You cannot write to the disk in drive '+DeviceName);
  161.          OutLine('because it has a write protect tab');
  162.          OutLine('attached.  Remove the tab to continue.')
  163.          end;
  164.       2: if DeviceName[2] = ':'                  { Problem with a drive or device }
  165.           then
  166.            begin
  167.            OutLine('Drive '+DeviceName+' is not ready.');
  168.            OutLine('Check the disk and close the door.')
  169.            end
  170.           else
  171.            OutLine('Printer is not ready.  Check device '+DeviceName);
  172.       9: OutLine('Printer ('+DeviceName+') is out of paper.');
  173.       else begin                                 { Handle bizarre errors more generically }
  174.            if DeviceName[2] = ':'
  175.             then
  176.              OutLine('Error with disk drive '+DeviceName)
  177.             else
  178.              OutLine('Check the printer. ('+DeviceName+')');
  179.            OutLine('');
  180.            OutLine('Problem is '+ErrorDesc[ErrorCode]);
  181.            end
  182.       end;
  183.     OutLine('');
  184.     OutLine('Hit ''A'' or CTRL BREAK to abort operation');
  185.     OutLine('or the SPACE BAR to try again.');
  186.     FastWrite('╚════════════════════════════════════════════╝',CurrentLine,18,Attr);
  187.  
  188.     for I := 1 to 3 do                           { Whistle at user }
  189.       begin
  190.       sound(800);
  191.       delay(100);
  192.       sound(600);
  193.       delay(100)
  194.       end;
  195.     NoSound;
  196.     while KeyPressed do                          { Clear keyboard buffer }
  197.       Key := ReadKey;
  198.     Key := ReadKey;
  199. {$IFDEF TPROF}
  200.     MoveScreen(SaveScreen,mem[VideoSegment:0],ScreenSize); { Restore display }
  201.     RestoreCursorState(SaveCursorLoc,SaveCursorSize);
  202. {$ELSE}
  203.     MoveToScreen(SaveScreen,mem[BaseOfScreen:0],ScreenSize); { Restore display }
  204.     SetCursor(SaveCursorSize);
  205.     SetCursorLoc(SaveX,SaveY);
  206. {$ENDIF}
  207.     TextAttr := SaveTextAttr;
  208.     CheckBreak := SaveCheckBreak;
  209.     case upcase(Key) of                          { Either retry operation or return an error depending on key hit }
  210.       ^C,^[,'A','Q': ;
  211.       else Retry := true                         { Since CriticalProc not restored, no more handlers will be called }
  212.       end;
  213.     while KeyPressed do                          { Clear keyboard buffer }
  214.       Key := ReadKey
  215.     end
  216.   end;
  217.  
  218. procedure ExitHandler;
  219.   { Restore the original Int24 handler }
  220.   begin
  221.   ExitProc := ExitSave;
  222.   SetIntVec($24,OldInt24)
  223.   end;
  224. {$F-}
  225.  
  226. begin
  227. ExitSave := ExitProc;
  228. ExitSave := @ExitHandler;
  229. CriticalProc := @DefaultCriticalHandler;
  230. GetIntVec($24,OldInt24);
  231. SetIntVec($24,@Int24Handler)
  232. end.
  233.